home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / defs.lisp < prev    next >
Lisp/Scheme  |  1990-12-05  |  23KB  |  702 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (eval-when (compile load eval)
  31.   
  32. (defvar *defclass-times*   '(load eval))    ;Probably have to change this
  33.                         ;if you use defconstructor.
  34. (defvar *defmethod-times*  '(load eval))
  35. (defvar *defgeneric-times* '(load eval))
  36.  
  37. )
  38.  
  39.  
  40. ;;;
  41. ;;; Convert a function name to its standard setf function name.  We have to
  42. ;;; do this hack because not all Common Lisps have yet converted to having
  43. ;;; setf function specs.
  44. ;;;
  45. ;;; In a port that does have setf function specs you can use those just by
  46. ;;; making the obvious simple changes to these functions.  The rest of PCL
  47. ;;; believes that there are function names like (SETF <foo>), this is the
  48. ;;; only place that knows about this hack.
  49. ;;;
  50. (eval-when (compile load eval)
  51.  
  52. (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
  53.  
  54. (defun get-setf-function-name (name)
  55.   (or (gethash name *setf-function-names*)
  56.       (setf (gethash name *setf-function-names*)
  57.         (intern (format nil
  58.                 "SETF ~A ~A"
  59.                 (package-name (symbol-package name))
  60.                 (symbol-name name))
  61.             *the-pcl-package*))))
  62.  
  63. ;;;
  64. ;;; Call this to define a setf macro for a function with the same behavior as
  65. ;;; specified by the SETF function cleanup proposal.  Specifically, this will
  66. ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
  67. ;;;
  68. ;;; do-standard-defsetf                  A macro interface for use at top level
  69. ;;;                                      in files.  Unfortunately, users may
  70. ;;;                                      have to use this for a while.
  71. ;;;                                      
  72. ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
  73. ;;; 
  74. ;;; do-standard-defsetf-1                A functional interface called by the
  75. ;;;                                      above, defmethod and defgeneric.
  76. ;;;                                      Since this is all a crock anyways,
  77. ;;;                                      users are free to call this as well.
  78. ;;;
  79. (defmacro do-standard-defsetf (&rest function-names)
  80.   `(eval-when (compile load eval)
  81.      (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
  82.  
  83. (defun do-standard-defsetfs-for-defclass (accessors)
  84.   (dolist (name accessors) (do-standard-defsetf-1 name)))
  85.  
  86. (defun do-standard-defsetf-1 (function-name)
  87.   (unless (setfboundp function-name)
  88.     (let* ((setf-function-name (get-setf-function-name function-name)))
  89.     
  90.       #+Genera
  91.       (let ((fn #'(lambda (form)
  92.             (lt::help-defsetf
  93.               '(&rest accessor-args) '(new-value) function-name 'nil
  94.               `(`(,',setf-function-name ,new-value .,accessor-args))
  95.               form))))
  96.     (setf (get function-name 'lt::setf-method) fn
  97.           (get function-name 'lt::setf-method-internal) fn))
  98.  
  99.       #+Lucid
  100.       (lucid::set-simple-setf-method 
  101.     function-name
  102.     #'(lambda (form new-value)
  103.         (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
  104.                      (cdr form)))
  105.            (vars (mapcar #'car bindings)))
  106.           ;; This may wrap spurious LET bindings around some form,
  107.           ;;   but the PQC compiler will unwrap then.
  108.           `(LET (,.bindings)
  109.          (,setf-function-name ,new-value . ,vars)))))
  110.       
  111.       #+kcl
  112.       (let ((helper (gensym)))
  113.     (setf (macro-function helper)
  114.           #'(lambda (form env)
  115.           (declare (ignore env))
  116.           (let* ((loc-args (butlast (cdr form)))
  117.              (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
  118.              (vars (mapcar #'car bindings)))
  119.             `(let ,bindings
  120.                (,setf-function-name ,(car (last form)) ,@vars)))))
  121.     (eval `(defsetf ,function-name ,helper)))
  122.       #+Xerox
  123.       (flet ((setf-expander (body env)
  124.            (declare (ignore env))
  125.            (let ((temps
  126.                (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
  127.                    (cdr body)))
  128.              (forms (cdr body))
  129.              (vars (list (gensym))))
  130.          (values temps
  131.              forms
  132.              vars
  133.              `(,setf-function-name ,@vars ,@temps)
  134.              `(,function-name ,@temps)))))
  135.     (let ((setf-method-expander (intern (concatenate 'string
  136.                                  (symbol-name function-name)
  137.                                  "-setf-expander")
  138.                      (symbol-package function-name))))
  139.       (setf (get function-name :setf-method-expander) setf-method-expander
  140.         (symbol-function setf-method-expander) #'setf-expander)))
  141.       
  142.       #-(or Genera Lucid kcl Xerox)
  143.       (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
  144.            `(,',setf-function-name ,new-value ,@accessor-args)))
  145.       
  146.       )))
  147.  
  148. (defun setfboundp (symbol)
  149.   #+Genera (not (null (get-properties (symbol-plist symbol)
  150.                       'lt::(derived-setf-function trivial-setf-method
  151.                         setf-equivalence setf-method))))
  152.   #+Lucid  (locally
  153.          (declare (special lucid::*setf-inverse-table*
  154.                    lucid::*simple-setf-method-table*
  155.                    lucid::*setf-method-expander-table*))
  156.          (or (gethash symbol lucid::*setf-inverse-table*)
  157.          (gethash symbol lucid::*simple-setf-method-table*)
  158.          (gethash symbol lucid::*setf-method-expander-table*)))
  159.   #+kcl    (or (get symbol 'si::setf-method)
  160.            (get symbol 'si::setf-update-fn)
  161.            (get symbol 'si::setf-lambda))
  162.   #+Xerox  (or (get symbol :setf-inverse)
  163.            (get symbol 'il:setf-inverse)
  164.            (get symbol 'il:setfn)
  165.            (get symbol :shared-setf-inverse)
  166.            (get symbol :setf-method-expander)
  167.            (get symbol 'il:setf-method-expander))
  168.  
  169.   #+:coral (or (get symbol 'ccl::setf-inverse)
  170.            (get symbol 'ccl::setf-method-expander))
  171.   
  172.   #-(or Genera Lucid KCL Xerox :coral) nil)
  173.  
  174. );eval-when
  175.  
  176.  
  177. ;;;
  178. ;;; PCL, like user code, must endure the fact that we don't have a properly
  179. ;;; working setf.  Many things work because they get mentioned by a defclass
  180. ;;; or defmethod before they are used, but others have to be done by hand.
  181. ;;; 
  182. (do-standard-defsetf
  183.   class-wrapper                    ;***
  184.   generic-function-name
  185.   method-function-plist
  186.   method-function-get
  187.   gdefinition
  188.   slot-value-using-class
  189.   )
  190.  
  191. (defsetf slot-value set-slot-value)
  192.  
  193.  
  194. ;;;
  195. ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
  196. ;;; function specs I wouldn't need this.  On the other hand, I don't like the
  197. ;;; way this really works so maybe function specs aren't really right either?
  198. ;;; 
  199. ;;; I also don't understand the real implications of a Lisp-1 on this sort of
  200. ;;; thing.  Certainly some of the lossage in all of this is because these
  201. ;;; SPECs name global definitions.
  202. ;;;
  203. ;;; Note that this implementation is set up so that an implementation which
  204. ;;; has a 'real' function spec mechanism can use that instead and in that way
  205. ;;; get rid of setf generic function names.
  206. ;;;
  207. (defmacro parse-gspec (spec
  208.                (non-setf-var . non-setf-case)
  209.                (setf-var . setf-case))
  210.   (declare (indentation 1 1))
  211.   (once-only (spec)
  212.     `(cond ((symbolp ,spec)
  213.         (let ((,non-setf-var ,spec)) ,@non-setf-case))
  214.        ((and (listp ,spec)
  215.          (eq (car ,spec) 'setf)
  216.          (symbolp (cadr ,spec)))
  217.         (let ((,setf-var (cadr ,spec))) ,@setf-case))
  218.        (t
  219.         (error
  220.           "Can't understand ~S as a generic function specifier.~%~
  221.                It must be either a symbol which can name a function or~%~
  222.                a list like ~S, where the car is the symbol ~S and the cadr~%~
  223.                is a symbol which can name a generic function."
  224.           ,spec '(setf <foo>) 'setf)))))
  225.  
  226. ;;;
  227. ;;; If symbol names a function which is traced or advised, return the
  228. ;;; unadvised, traced etc. definition.  This lets me get at the generic
  229. ;;; function object even when it is traced.
  230. ;;;
  231. (defun unencapsulated-fdefinition (symbol)
  232.   #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
  233.   #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
  234.   #+excl  (or (excl::encapsulated-basic-definition symbol)
  235.           (symbol-function symbol))
  236.   #+xerox (il:virginfn symbol)
  237.   
  238.   #-(or Lispm Lucid excl Xerox) (symbol-function symbol))
  239.  
  240. ;;;
  241. ;;; If symbol names a function which is traced or advised, redefine
  242. ;;; the `real' definition without affecting the advise.
  243. ;;;
  244. (defun fdefine-carefully (symbol new-definition)
  245.   #+Lispm (si:fdefine symbol new-definition t t)
  246.   #+Lucid (let ((lucid::*redefinition-action* nil))
  247.         (setf (symbol-function symbol) new-definition))
  248.   #+excl  (setf (symbol-function symbol) new-definition)
  249.   #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
  250.                 (brokenp (member symbol il:brokenfns :test #'eq)))
  251.         ;; In XeroxLisp (late of envos) tracing is implemented
  252.         ;; as a special case of "breaking".  Advising, however,
  253.         ;; is treated specially.
  254.             (xcl:unadvise-function symbol :no-error t)
  255.             (xcl:unbreak-function symbol :no-error t)
  256.             (setf (symbol-function symbol) new-definition)
  257.             (when brokenp (xcl:rebreak-function symbol))
  258.             (when advisedp (xcl:readvise-function symbol)))
  259.  
  260.   #-(or Lispm Lucid excl Xerox)
  261.   (setf (symbol-function symbol) new-definition)
  262.   
  263.   new-definition)
  264.  
  265. (defun gboundp (spec)
  266.   (parse-gspec spec
  267.     (name (fboundp name))
  268.     (name (fboundp (get-setf-function-name name)))))
  269.  
  270. (defun gmakunbound (spec)
  271.   (parse-gspec spec
  272.     (name (fmakunbound name))
  273.     (name (fmakunbound (get-setf-function-name name)))))
  274.  
  275. (defun gdefinition (spec)
  276.   (parse-gspec spec
  277.     (name (or (macro-function name)        ;??
  278.           (unencapsulated-fdefinition name)))
  279.     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
  280.  
  281. (defun SETF\ PCL\ GDEFINITION (new-value spec)
  282.   (parse-gspec spec
  283.     (name (fdefine-carefully name new-value))
  284.     (name (fdefine-carefully (get-setf-function-name name) new-value))))
  285.  
  286.  
  287. ;;;
  288. ;;; These functions are a pale imitiation of their namesake.  They accept
  289. ;;; class objects or types where they should.
  290. ;;; 
  291. (defun *typep (object type)
  292.   (if (classp type)
  293.       (let ((class (class-of object)))
  294.     (if class
  295.         (memq type (class-precedence-list class))
  296.         nil))
  297.       (let ((class (find-class type nil)))
  298.     (if class
  299.         (*typep object class)
  300.         (typep object type)))))
  301.  
  302. (defun *subtypep (type1 type2)
  303.   (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
  304.     (c2 (if (classp type2) type2 (find-class type2 nil))))
  305.     (if (and c1 c2)
  306.     (memq c2 (class-precedence-list c1))
  307.     (if (or c1 c2)
  308.         nil                    ;This isn't quite right, but...
  309.         (subtypep type1 type2)))))
  310.  
  311. (defun do-satisfies-deftype (name predicate)
  312.   (let* ((specifier `(satisfies ,predicate))
  313.      (expand-fn #'(lambda (&rest ignore)
  314.             (declare (ignore ignore))
  315.             specifier)))
  316.     ;; Specific ports can insert their own way of doing this.  Many
  317.     ;; ports may find the expand-fn defined above useful.
  318.     ;;
  319.     (or #+:Genera
  320.     (setf (get name 'deftype) expand-fn)
  321.     #+(and :Lucid (not :Prime))
  322.     (system::define-macro `(deftype ,name) expand-fn nil)
  323.     #+ExCL
  324.     (setf (get name 'excl::deftype-expander) expand-fn)
  325.     #+:coral
  326.     (setf (get name 'ccl::deftype-expander) expand-fn)
  327.  
  328.     ;; This is the default for ports for which we don't know any
  329.     ;; better.  Note that for most ports, providing this definition
  330.     ;; should just speed up class definition.  It shouldn't have an
  331.     ;; effect on performance of most user code.
  332.     (eval `(deftype ,name () '(satisfies ,predicate))))))
  333.  
  334. (defun make-type-predicate-name (name)
  335.   (intern (format nil
  336.           "TYPE-PREDICATE ~A ~A"
  337.           (package-name (symbol-package name))
  338.           (symbol-name name))
  339.       *the-pcl-package*))
  340.  
  341.  
  342.  
  343. (proclaim '(special *the-class-t* 
  344.             *the-class-vector* *the-class-symbol*
  345.             *the-class-string* *the-class-sequence*
  346.             *the-class-rational* *the-class-ratio*
  347.             *the-class-number* *the-class-null* *the-class-list*
  348.             *the-class-integer* *the-class-float* *the-class-cons*
  349.             *the-class-complex* *the-class-character*
  350.             *the-class-bit-vector* *the-class-array*
  351.  
  352.             *the-class-standard-object*
  353.             *the-class-class*
  354.             *the-class-method*
  355.             *the-class-generic-function*
  356.             *the-class-standard-class*
  357.             *the-class-standard-method*
  358.             *the-class-standard-generic-function*
  359.                 *the-class-standard-effective-slot-definition*
  360.  
  361.                 *the-eslotd-standard-class-slots*))
  362.  
  363. (proclaim '(special *the-wrapper-of-t*
  364.             *the-wrapper-of-vector* *the-wrapper-of-symbol*
  365.             *the-wrapper-of-string* *the-wrapper-of-sequence*
  366.             *the-wrapper-of-rational* *the-wrapper-of-ratio*
  367.             *the-wrapper-of-number* *the-wrapper-of-null*
  368.             *the-wrapper-of-list* *the-wrapper-of-integer*
  369.             *the-wrapper-of-float* *the-wrapper-of-cons*
  370.             *the-wrapper-of-complex* *the-wrapper-of-character*
  371.             *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
  372.  
  373.  
  374.  
  375. (defvar *built-in-class-symbols* ())
  376. (defvar *built-in-wrapper-symbols* ())
  377.  
  378. (defun get-built-in-class-symbol (class-name)
  379.   (or (cadr (assq class-name *built-in-class-symbols*))
  380.       (let ((symbol (intern (format nil
  381.                     "*THE-CLASS-~A*"
  382.                     (symbol-name class-name))
  383.                 *the-pcl-package*)))
  384.     (push (list class-name symbol) *built-in-class-symbols*)
  385.     symbol)))
  386.  
  387. (defun get-built-in-wrapper-symbol (class-name)
  388.   (or (cadr (assq class-name *built-in-wrapper-symbols*))
  389.       (let ((symbol (intern (format nil
  390.                     "*THE-WRAPPER-OF-~A*"
  391.                     (symbol-name class-name))
  392.                 *the-pcl-package*)))
  393.     (push (list class-name symbol) *built-in-wrapper-symbols*)
  394.     symbol)))
  395.  
  396.  
  397.  
  398.  
  399. (pushnew 'class *variable-declarations*)
  400. (pushnew 'variable-rebinding *variable-declarations*)
  401.  
  402. (defun variable-class (var env)
  403.   (caddr (variable-declaration 'class var env)))
  404.  
  405.  
  406. (defvar *boot-state* ())            ;NIL
  407.                         ;EARLY
  408.                         ;BRAID
  409.                         ;COMPLETE
  410.  
  411. (eval-when (load eval)
  412.   (when (eq *boot-state* 'complete)
  413.     (error "Trying to load (or compile) PCL in an environment in which it~%~
  414.             has already been loaded.  This doesn't work, you will have to~%~
  415.             get a fresh lisp (reboot) and then load PCL."))
  416.   (when *boot-state*
  417.     (cerror "Try loading (or compiling) PCL anyways."
  418.         "Trying to load (or compile) PCL in an environment in which it~%~
  419.              has already been partially loaded.  This may not work, you may~%~
  420.              need to get a fresh lisp (reboot) and then load PCL."))
  421.   )
  422.  
  423. ;;;
  424. ;;; This is used by combined methods to communicate the next methods to
  425. ;;; the methods they call.  This variable is captured by a lexical variable
  426. ;;; of the methods to give it the proper lexical scope.
  427. ;;; 
  428. (defvar *next-methods* nil)
  429.  
  430. (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
  431.  
  432. (defvar *umi-gfs*)
  433. (defvar *umi-complete-classes*)
  434. (defvar *umi-reorder*)
  435.  
  436. (defvar *invalidate-discriminating-function-force-p* ())
  437. (defvar *invalid-dfuns-on-stack* ())
  438.  
  439.  
  440. (defvar *standard-method-combination*)
  441.  
  442. (defvar *slotd-unsupplied* (list '*slotd-unsupplied*))    ;***
  443.  
  444.  
  445. (defmacro define-gf-predicate (predicate &rest classes)
  446.   `(progn (defmethod ,predicate ((x t)) nil)
  447.       ,@(mapcar #'(lambda (c) `(defmethod ,predicate ((x ,c)) t))
  448.             classes)))
  449.  
  450. (defmacro plist-value (object name)
  451.   `(with-slots (plist) ,object (getf plist ,name)))
  452.  
  453. (defsetf plist-value (object name) (new-value)
  454.   (once-only (new-value)
  455.     `(with-slots (plist) ,object
  456.        (if ,new-value
  457.        (setf (getf plist ,name) ,new-value)
  458.        (progn (remf plist ,name) nil)))))
  459.  
  460.  
  461.  
  462. (defvar *built-in-classes*
  463.   ;;
  464.   ;; name       supers     subs                     cdr of cpl
  465.   ;;
  466.   '((number     (t)        (complex float rational) (t))
  467.     (complex    (number)   ()                       (number t))
  468.     (float      (number)   ()                       (number t))
  469.     (rational   (number)   (integer ratio)          (number t))
  470.     (integer    (rational) ()                       (rational number t))
  471.     (ratio      (rational) ()                       (rational number t))
  472.  
  473.     (sequence   (t)        (list vector)            (t))
  474.     (list       (sequence) (cons null)              (sequence t))
  475.     (cons       (list)     ()                       (list sequence t))
  476.     
  477.  
  478.     (array      (t)        (vector)                 (t))
  479.     (vector     (array
  480.          sequence) (string bit-vector)      (array sequence t))
  481.     (string     (vector)   ()                       (vector array sequence t))
  482.     (bit-vector (vector)   ()                       (vector array sequence t))
  483.     (character  (t)        ()                       (t))
  484.    
  485.     (symbol     (t)        (null)                   (t))
  486.     (null       (symbol)   ()                       (symbol list sequence t))))
  487.  
  488.  
  489. ;;;
  490. ;;; The classes that define the kernel of the metabraid.
  491. ;;;
  492. (defclass t () ()
  493.   (:metaclass built-in-class))
  494.  
  495. (defclass standard-object (t) ())
  496.  
  497. (defclass metaobject (standard-object) ())
  498.  
  499. (defclass specializer (metaobject) ())
  500.  
  501. (defclass definition-source-mixin (standard-object)
  502.      ((source
  503.     :initform (load-truename)
  504.     :reader definition-source
  505.     :initarg :definition-source)))
  506.  
  507. (defclass plist-mixin (standard-object)
  508.      ((plist
  509.     :initform ())))
  510.  
  511. (defclass documentation-mixin (plist-mixin)
  512.      ())
  513.  
  514. (defclass dependent-update-mixin (plist-mixin)
  515.     ())
  516.  
  517. ;;;
  518. ;;; The class CLASS is a specified basic class.  It is the common superclass
  519. ;;; of any kind of class.  That is any class that can be a metaclass must
  520. ;;; have the class CLASS in its class precedence list.
  521. ;;; 
  522. (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
  523.                      specializer)
  524.      ((name
  525.     :initform nil
  526.     :initarg  :name
  527.     :accessor class-name)
  528.       (direct-superclasses
  529.     :initform ()
  530.     :reader class-direct-superclasses)
  531.       (direct-subclasses
  532.     :initform ()
  533.     :reader class-direct-subclasses)
  534.       (direct-methods
  535.     :initform (cons nil nil))))
  536.  
  537. ;;;
  538. ;;; The class PCL-CLASS is an implementation-specific common superclass of
  539. ;;; all specified subclasses of the class CLASS.
  540. ;;; 
  541. (defclass pcl-class (class)
  542.      ((class-precedence-list
  543.     :initform ())
  544.       (wrapper
  545.     :initform nil)))
  546.  
  547. ;;;
  548. ;;; The class STD-CLASS is an implementation-specific common superclass of
  549. ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
  550. ;;; 
  551. (defclass std-class (pcl-class)
  552.      ((direct-slots
  553.     :initform ()
  554.     :accessor class-direct-slots)
  555.       (slots
  556.     :initform ()
  557.     :accessor class-slots)
  558.       (no-of-instance-slots            ;*** MOVE TO WRAPPER ***
  559.     :initform 0
  560.     :accessor class-no-of-instance-slots)
  561.       (prototype
  562.     :initform nil)))
  563.  
  564. (defclass standard-class (std-class)
  565.      ())
  566.  
  567. (defclass funcallable-standard-class (std-class)
  568.      ())
  569.     
  570. (defclass forward-referenced-class (pcl-class) ())
  571.  
  572. (defclass built-in-class (pcl-class) ())
  573.  
  574.  
  575. ;;;
  576. ;;; Slot definitions.
  577. ;;;
  578. ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
  579. ;;;
  580. (defclass slot-definition (metaobject) ())
  581.  
  582. (defclass direct-slot-definition    (slot-definition) ())
  583. (defclass effective-slot-definition (slot-definition) ())
  584.  
  585. (defclass standard-slot-definition (slot-definition) 
  586.      ((name
  587.     :initform nil
  588.         :accessor slotd-name)
  589.       (initform
  590.     :initform *slotd-unsupplied*
  591.     :accessor slotd-initform)
  592.       (initfunction
  593.     :initform *slotd-unsupplied*
  594.     :accessor slotd-initfunction)
  595.       (readers
  596.     :initform nil
  597.     :accessor slotd-readers)
  598.       (writers
  599.     :initform nil
  600.     :accessor slotd-writers)
  601.       (initargs
  602.     :initform nil
  603.     :accessor slotd-initargs)
  604.       (allocation
  605.     :initform nil
  606.     :accessor slotd-allocation)
  607.       (type
  608.     :initform nil
  609.     :accessor slotd-type)
  610.       (documentation
  611.     :initform ""
  612.     :initarg :documentation)
  613.       (class
  614.         :initform nil
  615.     :accessor slotd-class)
  616.       (instance-index
  617.         :initform nil
  618.     :accessor slotd-instance-index)))
  619.  
  620. (defclass standard-direct-slot-definition (standard-slot-definition
  621.                        direct-slot-definition)
  622.      ())                    ;Adding slots here may
  623.                         ;involve extra work to
  624.                         ;the code in braid.lisp
  625.  
  626. (defclass standard-effective-slot-definition (standard-slot-definition
  627.                           effective-slot-definition)
  628.      ())                    ;Adding slots here may
  629.                         ;involve extra work to
  630.                         ;the code in braid.lisp
  631.  
  632.  
  633.  
  634. (defclass eql-specializer (specializer)
  635.      ((object :initarg :object :reader eql-specializer-object)))
  636.  
  637.  
  638.  
  639. ;;;
  640. ;;;
  641. ;;;
  642. (defmacro dolist-carefully ((var list improper-list-handler) &body body)
  643.   `(let ((,var nil)
  644.      (.dolist-carefully. ,list))
  645.      (loop (when (null .dolist-carefully.) (return nil))
  646.        (if (consp .dolist-carefully.)
  647.            (progn
  648.          (setq ,var (pop .dolist-carefully.))
  649.          ,@body)
  650.            (,improper-list-handler)))))
  651.  
  652. (defun legal-std-documentation-p (x)
  653.   (if (or (null x) (stringp x))
  654.       t
  655.       "a string or NULL"))
  656.  
  657. (defun legal-std-lambda-list-p (x)
  658.   (declare (ignore x))
  659.   t)
  660.  
  661. (defun legal-std-method-function-p (x)
  662.   (if (functionp x)
  663.       t
  664.       "a function"))
  665.  
  666. (defun legal-std-qualifiers-p (x)
  667.   (flet ((improper-list ()
  668.        (return-from legal-std-qualifiers-p "Is not a proper list.")))
  669.     (dolist-carefully (q x improper-list)
  670.       (let ((ok (legal-std-qualifier-p q)))
  671.     (unless (eq ok t)
  672.       (return-from legal-std-qualifiers-p
  673.         (format nil "Contains ~S which ~A" q ok)))))
  674.     t))
  675.  
  676. (defun legal-std-qualifier-p (x)
  677.   (if (and x (atom x))
  678.       t
  679.       "is not a non-null atom"))
  680.  
  681. (defun legal-std-slot-name-p (x)
  682.   (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
  683.     ((keywordp x)      "is a keyword and so cannot be bound")
  684.     ((memq x '(t nil)) "cannot be bound")
  685.     (t t)))
  686.  
  687. (defun legal-std-specializers-p (x)
  688.   (flet ((improper-list ()
  689.        (return-from legal-std-specializers-p "Is not a proper list.")))
  690.     (dolist-carefully (s x improper-list)
  691.       (let ((ok (legal-std-specializer-p s)))
  692.     (unless (eq ok t)
  693.       (return-from legal-std-specializers-p
  694.         (format nil "Contains ~S which ~A" s ok)))))
  695.     t))
  696.  
  697. (defun legal-std-specializer-p (x)
  698.   (if (or (classp x)
  699.       (eql-specializer-p x))
  700.       t
  701.       "is neither a class object nor an eql specializer"))
  702.